{-# LANGUAGE DeriveDataTypeable
           , FlexibleContexts
           , FlexibleInstances
           , MultiParamTypeClasses #-}
module Main where

import X

import Control.Applicative
import Control.Concurrent
import Control.Exception
import Control.Monad
import Control.Monad.Trans
import Data.Char
import Data.IORef
import Data.List hiding (group)
import Data.Maybe
import Graphics.X11.Xlib
import Graphics.X11.Xlib.Extras
import Prelude hiding (getContents, readFile)
import System.Console.CmdLib
import System.Environment
import System.Exit
import System.IO.Error
import System.IO.Strict (getContents, readFile)

data Main = Main
    { font       :: String
    , foreground :: String
    , background :: String
    , selected   :: String
    , matchCase  :: Bool
    , spacing    :: Int
    , bottom     :: Bool
    , fast       :: Bool
    , vertical   :: Int
    , highlight  :: String
    , version    :: Bool
    , prompt     :: String
    , cacheFile  :: String
    } deriving (Typeable, Data, Eq, Show)

instance Attributes Main where
    attributes _ = group "Options"
         [ font       %> [ Help "font"
                         , Long ["font", "fn"]
                         , ArgHelp "XLFD"
                         , Default "DejaVu Sans Mono-8" ]
         , foreground %> [ Help "defines the foreground color"
                         , Long ["nf", "fg"]
                         , ArgHelp "color"
                         , Default "#ffffff" ]
         , background %> [ Help "defines the background color"
                         , Long ["nb", "bg"]
                         , ArgHelp "color"
                         , Default "#000000" ]
         , selected   %> [ Help "defines the selected foreground color"
                         , Long ["sf"]
                         , ArgHelp "color"
                         , Default "#0000ff" ]
         , matchCase  %> [ Help "matches input case insensitive"
                         , Long ["i"]
                         , Default True ]
         , spacing    %> [ Help "space to reserve for input"
                         , Default (200 :: Int) ]
         , bottom     %> [ Help "(not implemented)"
                         , Long ["b", "bottom"] ]
         , fast       %> [ Help "grab keyboard before reading stdin"
                         , Long ["f", "fast"] ]
         , vertical   %> [ Help "(not implemented)"
                         , Long ["l", "lines"] ]
         , prompt     %> [ Help "(not implemented)"
                         , Long ["p", "prompt"] ]
         , highlight  %> [ Help "(not implemented)"
                         , Long ["sb"]
                         , Default "#000000" ]
         , version    %> [ Help "(not implemented)"
                         , Long ["v", "version"] ]
         , cacheFile  %> [ Help "filename of item cache (implies --fast)"
                         , Long ["cache"]
                         , Default "" ]
         ]

instance RecordCommand Main

data St = St
    { input  :: String
    , result :: Maybe String
    , items  :: [String]
    }

modifyInput :: (String -> String) -> St -> St
modifyInput  f st = st { input  = f (input st) }

modifyItems :: ([String] -> [String]) -> St -> St
modifyItems  f st = st { items  = f (items st) }

modifyResult :: (Maybe String -> Maybe String) -> St -> St
modifyResult f st = st { result = f (result st) }

newItems :: [String] -> St -> St
newItems = (modifyItems . const) . sort

main :: IO ()
main = do
    opts  <- executeR Main {} . map fixArg =<< getArgs
    title <- getProgName

    sRef <- newIORef $ St "" Nothing []
    if fast opts || not (null (cacheFile opts)) then do
        when (not (null (cacheFile opts))) $ do
            let fn = cacheFile opts
            items' <- tryJust (guard . isDoesNotExistError) (readFile fn)
            modifyIORef sRef $ newItems $ either (const []) lines items'
        void $ forkIO $ modifyIORef sRef . newItems . lines =<< getContents
      else do
        modifyIORef sRef . (modifyItems . const) . sort . lines =<< getContents

    runX title 0 0 Nothing Nothing (font opts) $ \e -> do
        ev <- liftIO $ getEvent e
        case ev of
            KeyEvent et _ _ _ _ _ _ _ _ _ _ _ _ _ _ ->
                when (et == keyPress) $ liftIO $
                    keycode sRef . snd =<< lookupString (asKeyEvent e)
            _ -> return ()

        st <- liftIO $ readIORef sRef
        let matches 
                | matchCase opts
                = filter (isPrefixOf (lower (input st)) . lower) (items st)
                | otherwise
                = filter (isPrefixOf (input st)) (items st)
            n       = length (input st)
            (r:rs)  | null matches = [""]
                    | otherwise    = matches

        clear (background opts)
        _ <- string (foreground opts) (input st)
        moveTo (spacing opts)
        _ <- string (selected opts) (take n r)
        untilFalse $ map (string (foreground opts))
                         (intersperse "   " (drop n r:rs))
   
    unless (null (cacheFile opts)) $ do
        writeFile (cacheFile opts) . unlines . items =<< readIORef sRef

    r' <- result <$> readIORef sRef
    case r' of
        Just r -> do
            putStrLn r
            exitWith ExitSuccess
        _ -> exitWith (ExitFailure 1)
  where
    lower = map toLower

    untilFalse []     = return ()
    untilFalse (m:ms) = flip when (untilFalse ms) =<< m

    fixArg s | "-" == take 1 s && "--" /= take 2 s = '-':s
             | otherwise                           = s

keycode :: IORef St -> String -> IO ()

keycode _ "\ESC" = throw UserInterrupt

keycode sRef "\r" = do
    st <- readIORef sRef
    let r | null (input st) = Nothing
          | null (items st) = Nothing
          | otherwise
          = safeHead $ filter (input st `isPrefixOf`) (items st)
    writeIORef sRef (modifyResult (const r) st)
    throw UserInterrupt
  where safeHead [] = Nothing
        safeHead xs = Just (head xs)

keycode sRef "\b" = modifyIORef sRef (modifyInput safeInit)
  where safeInit [] = []
        safeInit xs = init xs 

keycode sRef "\NAK" = modifyIORef sRef (modifyInput (const ""))

keycode sRef s
    | printable s = modifyIORef sRef (modifyInput (++s))
    | otherwise   = return ()
  where
    printable c | c `elem` map ((:[]) . chr) [32 .. 126] = True
                | otherwise = False

